home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / popen.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  7.2 KB  |  206 lines
  1. ;; popen emulation, for non-stdio based ports.
  2.  
  3. ;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;;
  20. ;;;; As a special exception, the Free Software Foundation gives permission
  21. ;;;; for additional uses of the text contained in its release of GUILE.
  22. ;;;;
  23. ;;;; The exception is that, if you link the GUILE library with other files
  24. ;;;; to produce an executable, this does not by itself cause the
  25. ;;;; resulting executable to be covered by the GNU General Public License.
  26. ;;;; Your use of that executable is in no way restricted on account of
  27. ;;;; linking the GUILE library code into it.
  28. ;;;;
  29. ;;;; This exception does not however invalidate any other reasons why
  30. ;;;; the executable file might be covered by the GNU General Public License.
  31. ;;;;
  32. ;;;; This exception applies only to the code released by the
  33. ;;;; Free Software Foundation under the name GUILE.  If you copy
  34. ;;;; code from other Free Software Foundation releases into a copy of
  35. ;;;; GUILE, as the General Public License permits, the exception does
  36. ;;;; not apply to the code that you add in this way.  To avoid misleading
  37. ;;;; anyone as to the status of such modified files, you must delete
  38. ;;;; this exception notice from them.
  39. ;;;;
  40. ;;;; If you write modifications of your own for GUILE, it is your choice
  41. ;;;; whether to permit this exception to apply to your modifications.
  42. ;;;; If you do not wish that, delete this exception notice.
  43. ;;;; 
  44.  
  45. (define-module (ice-9 popen)
  46.   :export (port/pid-table open-pipe close-pipe open-input-pipe
  47.        open-output-pipe))
  48.  
  49. ;;    (define-module (guile popen)
  50. ;;      :use-module (guile posix))
  51.  
  52. ;; a guardian to ensure the cleanup is done correctly when
  53. ;; an open pipe is gc'd or a close-port is used.
  54. (define pipe-guardian (make-guardian))
  55.  
  56. ;; a weak hash-table to store the process ids.
  57. (define port/pid-table (make-weak-key-hash-table 31))
  58.  
  59. (define (ensure-fdes port mode)
  60.   (or (false-if-exception (fileno port))
  61.       (open-fdes *null-device* mode)))
  62.  
  63. ;; run a process connected to an input or output port.
  64. ;; mode: OPEN_READ or OPEN_WRITE.
  65. ;; returns port/pid pair.
  66. (define (open-process mode prog . args)
  67.   (let ((p (pipe))
  68.     (reading (string=? mode OPEN_READ)))
  69.     (setvbuf (cdr p) _IONBF)
  70.     (let ((pid (primitive-fork)))
  71.       (cond ((= pid 0)
  72.          ;; child
  73.          (set-batch-mode?! #t)
  74.  
  75.          ;; select the three file descriptors to be used as
  76.          ;; standard descriptors 0, 1, 2 for the new process.  one
  77.          ;; is the pipe to the parent, the other two are taken
  78.          ;; from the current Scheme input/output/error ports if
  79.          ;; possible.
  80.  
  81.          (let ((input-fdes (if reading
  82.                    (ensure-fdes (current-input-port)
  83.                         O_RDONLY)
  84.                    (fileno (car p))))
  85.            (output-fdes (if reading
  86.                     (fileno (cdr p))
  87.                     (ensure-fdes (current-output-port)
  88.                          O_WRONLY)))
  89.            (error-fdes (ensure-fdes (current-error-port)
  90.                         O_WRONLY)))
  91.  
  92.            ;; close all file descriptors in ports inherited from
  93.            ;; the parent except for the three selected above.
  94.            ;; this is to avoid causing problems for other pipes in
  95.            ;; the parent.
  96.  
  97.            ;; use low-level system calls, not close-port or the
  98.            ;; scsh routines, to avoid side-effects such as
  99.            ;; flushing port buffers or evicting ports.
  100.  
  101.            (port-for-each (lambda (pt-entry)
  102.                 (false-if-exception
  103.                  (let ((pt-fileno (fileno pt-entry)))
  104.                    (if (not (or (= pt-fileno input-fdes)
  105.                         (= pt-fileno output-fdes)
  106.                         (= pt-fileno error-fdes)))
  107.                        (close-fdes pt-fileno))))))
  108.  
  109.            ;; copy the three selected descriptors to the standard
  110.            ;; descriptors 0, 1, 2.  note that it's possible that
  111.            ;; output-fdes or input-fdes is equal to error-fdes.
  112.  
  113.            (cond ((not (= input-fdes 0))
  114.               (if (= output-fdes 0)
  115.               (set! output-fdes (dup->fdes 0)))
  116.               (if (= error-fdes 0)
  117.               (set! error-fdes (dup->fdes 0)))
  118.               (dup2 input-fdes 0)))
  119.  
  120.            (cond ((not (= output-fdes 1))
  121.               (if (= error-fdes 1)
  122.               (set! error-fdes (dup->fdes 1)))
  123.               (dup2 output-fdes 1)))
  124.  
  125.            (dup2 error-fdes 2)
  126.              
  127.            (apply execlp prog prog args)))
  128.  
  129.         (else
  130.          ;; parent
  131.          (if reading
  132.          (close-port (cdr p))
  133.          (close-port (car p)))
  134.          (cons (if reading
  135.                (car p)
  136.                (cdr p))
  137.            pid))))))
  138.  
  139. (define (open-pipe command mode)
  140.   "Executes the shell command @var{command} (a string) in a subprocess.
  141. A pipe to the process is created and returned.  @var{modes} specifies
  142. whether an input or output pipe to the process is created: it should 
  143. be the value of @code{OPEN_READ} or @code{OPEN_WRITE}."
  144.   (let* ((port/pid (open-process mode "/bin/sh" "-c" command))
  145.      (port (car port/pid)))
  146.     (pipe-guardian port)
  147.     (hashq-set! port/pid-table port (cdr port/pid))
  148.     port))
  149.  
  150. (define (fetch-pid port)
  151.   (let ((pid (hashq-ref port/pid-table port)))
  152.     (hashq-remove! port/pid-table port)
  153.     pid))
  154.  
  155. (define (close-process port/pid)
  156.   (close-port (car port/pid))
  157.   (cdr (waitpid (cdr port/pid))))
  158.  
  159. ;; for the background cleanup handler: just clean up without reporting
  160. ;; errors.  also avoids blocking the process: if the child isn't ready
  161. ;; to be collected, puts it back into the guardian's live list so it
  162. ;; can be tried again the next time the cleanup runs.
  163. (define (close-process-quietly port/pid)
  164.   (catch 'system-error
  165.      (lambda ()
  166.        (close-port (car port/pid)))
  167.      (lambda args #f))
  168.   (catch 'system-error
  169.      (lambda ()
  170.        (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
  171.          (cond ((= (car pid/status) 0)
  172.             ;; not ready for collection
  173.             (pipe-guardian (car port/pid))
  174.             (hashq-set! port/pid-table
  175.                 (car port/pid) (cdr port/pid))))))
  176.      (lambda args #f)))
  177.  
  178. (define (close-pipe p)
  179.   "Closes the pipe created by @code{open-pipe}, then waits for the process
  180. to terminate and returns its status value, @xref{Processes, waitpid}, for
  181. information on how to interpret this value."
  182.   (let ((pid (fetch-pid p)))
  183.     (if (not pid)
  184.         (error "close-pipe: pipe not in table"))
  185.     (close-process (cons p pid))))
  186.  
  187. (define reap-pipes
  188.   (lambda ()
  189.     (let loop ((p (pipe-guardian)))
  190.       (cond (p 
  191.          ;; maybe removed already by close-pipe.
  192.          (let ((pid (fetch-pid p)))
  193.            (if pid
  194.            (close-process-quietly (cons p pid))))
  195.          (loop (pipe-guardian)))))))
  196.  
  197. (add-hook! after-gc-hook reap-pipes)
  198.  
  199. (define (open-input-pipe command)
  200.   "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
  201.   (open-pipe command OPEN_READ))
  202.  
  203. (define (open-output-pipe command)
  204.   "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
  205.   (open-pipe command OPEN_WRITE))
  206.